Pensieve header: Verifying the w-Alexander link relations produced by wAlexanderLinkRelations.m using pA.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2010-08"];
<< wAlexanderLinkRelations.m
<< pA.m

Some further pA values from WSofMVA.nb:

pA[P[i_,j_]] := AHD[
t[i]==t[j], {i}, W[j],
W[j]-W[i]
];
pA[SVXp[i_,j_,k_,l_]] := AHD[
(t[i]==t[k])(t[j]==t[l]), {i,j}, W[k,l],
-W[i,k]+t[j] W[i,k]+W[i,l]-t[i] W[i,l]-W[k,l]+t[i] W[k,l]
];
pA[B[i_, j_]] := AHD[
(t[i]==t[j]), {i}, W[j], W[i]-t[i] W[i]-W[j]+t[i] W[j]
];

wJD[wjd_wJD] := wjd;
wJD[s_Plus] := wJD /@ s;
wJD[c_?NumberQ*expr_] := c wJD[expr];
wJD[p_Times] := Join @@ (wJD @@ (wJD /@ p));
wJD[(el_)^(k_)] := wJD @@ Table[el, {k}];
pW[n_, wjd_wJD] := Module[
{multiperms, i, j, allpdirs, pdirs, ks, p, ti, tj},
multiperms = Table[
Permutations[Range[Count[wjd, i, Infinity]]],
{i, n}
];
If[MemberQ[multiperms, {{}}], 0,
allpdirs=Flatten[Outer[pdirs, Sequence @@ multiperms, 1]];
Expand[
Sum[
ks = Table[0, {n}];
Last[pA[Join[
(CircuitDiagram @@ wjd) /. {
x[i_] :> (
ti = 10i+p[[i, ++ks[[i]]]];
B[ti-1, ti]
),
a[i_, j_] :> (
ti = 10i+p[[i, ++ks[[i]]]];
tj = 10j+p[[j, ++ks[[j]]]];
SVXp[ti-1, tj-1, ti, tj]
)
},
CircuitDiagram @@  Table[P[10i+ks[[i]], 10i], {i, 2, n}]
]]],
{p, allpdirs}
] /. {W[10] -> 1, W[_] -> 0} /. t[i_] :> x[i/10]+1
]
] 
];
pW[n_, expr_] := Expand[expr /. wjd_wJD :> pW[n, wjd]]

{s0, s1} = {1, 1};
rrels=wJD /@ RRels[2,1];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, -1};
rrels=wJD /@ RRels[2,1];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {1, 1};
rrels=wJD /@ RRels[2,2];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, -1};
rrels=wJD /@ RRels[2,2];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {1, -1};
rrels=wJD /@ RRels[2,2];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, 1};
rrels=wJD /@ RRels[2,2];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {1, 1};
rrels=wJD /@ RRels[2,3];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, -1};
rrels=wJD /@ RRels[2,3];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {1, -1};
rrels=wJD /@ RRels[2,3];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, 1};
rrels=wJD /@ RRels[2,3];
Table[pW[2, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, -1};
rrels=wJD /@ RRels[3,2];
Table[pW[3, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {1, 1};
rrels=wJD /@ RRels[3,2];
Table[pW[3, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, -1};
rrels=wJD /@ RRels[3,3];
Table[pW[3, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {1, 1};
rrels=wJD /@ RRels[3,3];
Table[pW[3, rrels[[k]]], {k, Length[rrels]}]

{s0, s1} = {-1, -1}; 
pWRank[m_] := Module[
{mons, mat, im},
mons = Table[x[1]^i x[2]^(m-i), {i,0,m}];
mat = DeleteCases[
Sort[
pW[2, #]& /@ (wJD /@ Gens[2,m]) 
],
0
] /. Thread[mons -> IdentityMatrix[m+1]];
{
im=DeleteCases[RowReduce[mat].mons, 0],
Length[im]
}
]

Table[
Print[m -> (r=pWRank[m])]; r,
{m,4}
]

Print[# -> pW[2, wJD[#]]]& /@ Gens[2,1]; RRels[2,1]

Print[# -> pW[2, wJD[#]]]& /@ Gens[2,2]; RRels[2,2]

Print[# -> pW[2, wJD[#]]]& /@ Gens[2,3]; RRels[2,3]

Print[# -> pW[2, wJD[#]]]& /@ Gens[2,4]; RRels[2,4]